home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Tech Arsenal 1
/
Tech Arsenal (Arsenal Computer).ISO
/
tek-06
/
btp15.zip
/
BTP.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1991-11-09
|
41KB
|
1,040 lines
UNIT BTP; {Version 1.5 11/9/91 (C) 1991 John C. Leon}
{$A+} {word alignment. Btrieve interface call wants this global directive
set; is the default compiler setting anyway. }
INTERFACE
(* ------------------------------------------------------------------------ *)
(* ------------------------------------------------------------------------ *)
USES Objects, Memory;
CONST
{ Key Attributes Key Types Open Modes }
{ ------------------ ---------------- --------------- }
Duplicates = 1; BString = 0; Normal = 0;
Modifiable = 2; BInteger = 1; Accel = -1;
Binary = 4; BFloat = 2; ReadOnly = -2;
Null = 8; BDate = 3; Verify = -3;
Segmented = 16; BTime = 4; Exclusive = -4;
AltCol = 32; BDecimal = 5;
Descending = 64; BMoney = 6; { File Flags }
Supplemental = 128; BLogical = 7; { ------------------------ }
ExtType = 256; BNumeric = 8; VarLength = 1;
Manual = 512; BBFloat = 9; BlankTrunc = 2;
BLString = 10; PreAllocate = 4;
BZString = 11; DataComp = 8;
BUnsBinary = 14; KeyOnly = 16;
BAutoInc = 15; Free10 = 64;
Free20 = 128;
Free30 = 192;
{ Btrieve Op Codes Error Codes }
{ ----------------------------------------- ------------------------ }
BOpen = 0; BAbortTran = 21; FileNotOpen = 3;
BClose = 1; BGetPos = 22; InvalidKeyNumber = 6;
BInsert = 2; BGetDir = 23; DiffKeyNumber = 7;
BUpdate = 3; BStepNext = 24; InvalidPosition = 8;
BDelete = 4; BStop = 25; EndofFile = 9;
BGetEqual = 5; BVersion = 26; FileNotFound = 12;
BGetNext = 6; BUnlock = 27; DataBufferLength = 22;
BGetPrev = 7; BReset = 28; RejectCount = 60;
BGetGr = 8; BSetOwner = 29; IncorrectDesc = 62;
BGetGrEq = 9; BClrOwner = 30; FilterLimit = 64;
BGetLess = 10; BCrSuppIdx = 31; IncorrectFldOff = 65;
BGetLessEq = 11; BDropSuppIdx = 32; LostPosition = 82;
BGetFirst = 12; BStepFirst = 33;
BGetLast = 13; BStepLast = 34;
BCreate = 14; BStepPrev = 35;
BStat = 15; BGetNextExt = 36;
BExtend = 16; BGetPrevExt = 37;
BSetDosDir = 17; BStepNextExt = 38;
BGetDosDir = 18; BStepPrevExt = 39;
BBegTran = 19; BInsertExt = 40;
BEndTran = 20; BGetKey = 50;
{ Extended Ops Comp Codes/Bias Extended Ops Logic Constants }
{ ----------------------------- ----------------------------------- }
Equal : byte = 1; NoFilter : integer = 0;
GreaterThan : byte = 2; LastTerm : byte = 0;
LessThan : byte = 3; NextTermAnd : byte = 1;
NotEqual : byte = 4; NextTermOr : byte = 2;
GrOrEqual : byte = 5;
LessOrEqual : byte = 6;
UseAltColl : byte = 32;
UseField : byte = 64;
UseNoCase : byte = 128;
{ Other Unit-Specific Constants }
{ --------------------------------- }
Zero : integer = 0;
NotRequired : integer = 0;
MaxFixedRecLength = 4090; {Btrieve limits fixed record length for std }
MaxKBufferLength = 255; {files to 4090. Max key size is 255. }
MaxExtDBufferLength = 32767;
TYPE
(* Data types for TRecMgr object *)
(* ----------------------------- *)
TVersion = record
case integer of
1: (Number : word;
Rev : integer;
Product : char);
2: (Entire : array[1..5] of char);
end;
PRecMgr = ^TRecMgr;
TRecMgr = object(TObject) {Base obj handles abort/begin/end}
Version : TVersion;{tran, reset, version and stop. }
VersionString: string;
constructor Init;
function BT(OpCode, Key: integer): integer; virtual;
destructor Done; virtual;
end;
(* Data types for BFile object *)
(* --------------------------- *)
BFileName = array[1..80] of char; {79 + blank pad required by Btrieve}
TAltColSpec = record {The data types for alternate collating}
case integer of {sequence are used in CreateFile fcn. }
1: (Header : byte; {Header always equals $AC}
Name : array[1..8] of char;
Table : array[1..256] of char);
2: (Entire : array[1..265] of byte);
end;
PAltColSeq = ^TAltColSeq;
TAltColSeq = object(TObject)
Spec : TAltColSpec;
constructor Init(SpecName: FNameStr);
destructor Done; virtual;
end;
PKeySpec = ^KeySpec;
KeySpec = record {data type for a Btrieve key spec}
case integer of
1: (KeyPos : integer;
KeyLen : integer;
KeyFlags : integer; {Tho not used in a }
NotUsed : array[1..4] of byte; {create call, these}
ExtKeyType : byte; {4 bytes return # }
NullValue : byte; {unique recs in key}
Reserved : array[1..4] of byte);{after a stat call.}
2: (Irrelevant : array[1..3] of integer;
NumUnique : longint); {great after a stat call!}
3: (Entire : array[1..16] of byte);
end;
PFileSpec = ^TFileSpec;
TFileSpec = record {Strictly speaking, the KeyArray}
case integer of {and AltColSpec elements here }
1: (RecLen : integer;{only serve to reserve space for}
PageSize : integer;{the buffer. }
NumKeys : integer;
NumRecs : array[1..2] of integer;
FileFlags : integer;
Reserved : array[1..2] of char;
PreAlloc : integer;
KeyArray : array[0..23] of KeySpec; {24=max # segs}
AltColSpec : TAltColSpec); {here just to allow room}
2: (Irrelevant : array[1..14] of byte;
UnusedPgs : word); {great after a stat call!}
3: (SpecBuf : integer); {used to refer to addr of spec}
4: (Entire : array[1..665] of byte);
end;
PBFile = ^BFile;
BFile = object(TObject)
DFileName : FNameStr; {DOS filename}
Specs : TFileSpec; {Btrieve file specs}
SpecLength : integer; {length of actual file spec}
NumRecs : longint; {# records at Init time}
NumSegs : integer; {total # key segs}
HasAltCol : boolean; {true if file has alt col seq}
AltColName : string[8]; {name of alt col seq from file}
PosBlk : array[1..128] of char; {position block}
DBufferLen : integer;
constructor Init(UserFileName: FNameStr; OpenMode: integer);
function BT(OpCode, Key: integer): integer; virtual;
function Open(OpenMode: integer): integer; virtual;
function Close: integer; virtual;
destructor Done; virtual;
private
FileName : BFileName; {Btrieve-type filename}
procedure ConvertName(UserFileName: FNameStr);
end;
(* Data types for BFixed object - descendant of BFile *)
(* -------------------------------------------------- *)
TDBuffer = array[1..MaxFixedRecLength] of byte;
TKBuffer = array[1..MaxKBufferLength] of byte;
PBFixed = ^BFixed;
BFixed = object(BFile)
DBuffer : TDBuffer;
KBuffer : TKBuffer;
constructor Init(UserFileName: FNameStr; OpenMode: integer);
function BT(OpCode, Key: integer): integer; virtual;
destructor Done; virtual;
end;
(* Data types for BFileExt object - descendant of BFile *)
(* ---------------------------------------------------- *)
TCharArray = array[1..255] of char;
THeader = record
case integer of
1: (DBufferLen : integer;
Constant : array[1..2] of char);
2: (Entire : array[1..4] of byte);
end;
TFilter = record
case integer of
1: (MaxSkip : integer;
NumLogicTerms : integer);
2: (Entire : array[1..2] of integer);
end;
TLogicTerm = record
case integer of
1: (FieldType : byte;
FieldLen : integer;
Offset : integer; {0 relative to start of record}
CompCode : byte;
Expression : byte;{0 last term, 1 AND next, 2 OR next}
case FieldComp: boolean of
True : (CompOffset: integer);
False: (Value: TCharArray));{an arbitrary limit of}
2: (Fixed : array[1..7] of byte); {255 on len of values }
end;
PFilterSpec = ^TFilterSpec;
TFilterSpec = object(TObject)
LogicTerm: TLogicTerm;
constructor InitF(FieldType: byte; FieldLen, Offset:
integer; CompCode, Expression: byte;
CompOffset: integer);
constructor InitV(FieldType: byte; FieldLen, Offset:
integer; CompCode, Expression: byte;
Value: TCharArray);
destructor Done; virtual;
end;
TExtractor = record
case integer of
1: (NumRecords : integer;
NumFields : integer);
2: (Entire : array[1..2] of integer);
end;
TExtRepeater= record
FieldLen : integer;
Offset : integer;
end;
PExtSpec = ^TExtSpec;
TExtSpec = object(TObject)
ExtRepeater : TExtRepeater;
constructor Init(Len, Ofs: integer);
destructor Done; virtual;
end;
PExtDBuffer = ^TExtDBuffer;
TExtDBuffer = record
case integer of
1: (Header : THeader; {Buffer sent includes these}
Filter : TFilter); {types at its beginning.}
2: (NumRecs : integer; {Buffer rec'd looks}
Repeater : array[1..32765] of char); {like this.}
{Repeater structure is: 2 for length of record image, }
{ 4 for currency position of rec, }
{ n for record image itself }
3: (Entire : array[1..32767] of byte); {Whole buffer.}
end;
PBFileExt = ^BFileExt;
BFileExt = object(BFile)
Header : THeader;
Filter : TFilter;
FilterSpec : PCollection;
Extractor : TExtractor;
ExtractorSpec : PCollection;
ExtDBuffer : PExtDBuffer;
constructor Init(UserFileName: FNameStr; OpenMode: integer);
function BTExt(OpCode, Key: integer): integer; virtual;
destructor Done; virtual;
private
procedure SetExtDBufferLen;
procedure MakeExtDBuffer;
end;
(* PUBLIC/EXPORTED VARS *)
(* -------------------- *)
VAR
BStatus : integer;
VarNotRequired : integer; {Dummy parameter.}
VarPosBlk : array[1..128] of char; {Dummy used in ops that don't}
{pass/return position block. }
(* PUBLIC/EXPORTED FUNCTIONS *)
(* ------------------------- *)
{The Btrv function declared here is public, but should not ever be needed. It
is included in the public declaration only to be complete and give you
access to the standard call if you should need it.}
function Btrv(Op:integer; var Pos,Data; var DataLen:integer; var KBuf;
Key:integer): integer;
function CreateFile(UserFileName: FNameStr; UserFileSpec:PFileSpec;
AltColFile: FNameStr): integer;
function CloneFile(CurrentFile, NewFile: FNameStr): integer;
function LTrim(S: String): String; {LTrim and RTrim were taken from one of }
function RTrim(S: String): String; {the Turbo Vision .PAS source files. }
IMPLEMENTATION
(* ------------------------------------------------------------------------ *)
(* ------------------------------------------------------------------------ *)
USES Dos; {Dos unit needed for the Btrieve interface call (interrupts)}
{$R-} {Range checking off...is TP's default}
{$B+} {Boolean complete evaluation on...NOT a default, but apparently
required by the interface call. Is turned off at end of Btrieve
interface definition}
{$V-} {Non-strict string var checking...Btrieve wants it so. Strict
checking is turned back on at the end of the interface definition.}
{$S+} {Stack checking on}
{$I+} {I/O checking on}
{ Module Name: TUR5BTRV.PAS }
{ Description: This is the Btrieve interface for Turbo Pascal (MS-DOS). }
{ This routine sets up the parameter block expected by }
{ Btrieve, and issues interrupt 7B. It should be compiled }
{ with the $V- switch so that runtime checks will not be }
{ performed on the variable parameters. }
{ }
{ Synopsis: STAT := BTRV (OP, POS.START, DATA.START, DATALEN, }
{ KBUF.START, KEY); }
{ where }
{ OP is an integer, }
{ POS is a 128 byte array, }
{ DATA is an untyped parameter for the data buffer, }
{ DATALEN is the integer length of the data buffer, }
{ KBUF is the untyped parameter for the key buffer, }
{ and KEY is an integer. }
{ }
{ Returns: Btrieve status code (see Appendix B of the Btrieve Manual). }
{ }
{ Note: The Btrieve manual states that the 2nd, 3rd, and 5th }
{ parameters be declared as variant records, with an integer }
{ type as one of the variants (used only for Btrieve calls), }
{ as is shown in the example below. This is supported, but }
{ the restriction is no longer necessary. In other words, any }
{ variable can be sent in those spots as long as the variable }
{ uses the correct amount of memory so Btrieve does not }
{ overwrite other variables. }
{ }
{ var DATA = record case boolean of }
{ FALSE: ( START: integer ); }
{ TRUE: ( EMPLOYEE_ID: 0..99999; }
{ EMPLOYEE_NAME: packed array[1..50] of char; }
{ SALARY: real; }
{ DATA_OF_HIRE: DATE_TYPE ); }
{ end; }
{ }
{ There should NEVER be any string variables declared in the }
{ data or key records, because strings store an extra byte for }
{ the length, which affects the total size of the record. }
{ }
{ }
(* BTRV function *)
(* ------------- *)
function Btrv (Op: integer; var Pos, Data; var DataLen: integer; var Kbuf;
Key: integer): integer;
const
VAR_ID = $6176; {id for variable length records - 'va'}
BTR_INT = $7B;
BTR2_INT = $2F;
BTR_OFFSET = $0033;
MULTI_FUNCTION = $AB;
{ ProcId is used for communicating with the Multi Tasking Version of }
{ Btrieve. It contains the process id returned from BMulti and should }
{ not be changed once it has been set. }
{ }
ProcId: integer = 0; { initialize to no process id }
MULTI: boolean = false; { set to true if BMulti is loaded }
VSet: boolean = false; { set to true if we have checked for BMulti }
type
ADDR32 = record {32 bit address}
OFFSET : word; {&&&old->integer}
SEGMENT: word; {&&&used->integer}
end;
BTR_PARMS = record
USER_BUF_ADDR: ADDR32; {data buffer address}
USER_BUF_LEN: integer; {data buffer length}
USER_CUR_ADDR: ADDR32; {currency block address}
USER_FCB_ADDR: ADDR32; {file control block address}
USER_FUNCTION: integer; {Btrieve operation}
USER_KEY_ADDR: ADDR32; {key buffer address}
USER_KEY_LENGTH: BYTE; {key buffer length}
USER_KEY_NUMBER: shortint; {key number&&&old->BYTE}
USER_STAT_ADDR: ADDR32; {return status address}
XFACE_ID: integer; {language interface id}
end;
var
STAT: integer; {Btrieve status code}
XDATA: BTR_PARMS; {Btrieve parameter block}
REGS: Dos.Registers; {register structure used on interrrupt call}
DONE: boolean;
begin
REGS.AX := $3500 + BTR_INT;
INTR ($21, REGS);
if (REGS.BX <> BTR_OFFSET) then {make sure Btrieve is installed}
STAT := 20
else
begin
if (not VSet) then {if we haven't checked for Multi-User version}
begin
REGS.AX := $3000;
INTR ($21, REGS);
if ((REGS.AX AND $00FF) >= 3) then
begin
VSet := true;
REGS.AX := MULTI_FUNCTION * 256;
INTR (BTR2_INT, REGS);
MULTI := ((REGS.AX AND $00FF) = $004D);
end
else
MULTI := false;
end;
{make normal btrieve call}
with XDATA do
begin
USER_BUF_ADDR.SEGMENT := SEG (DATA);
USER_BUF_ADDR.OFFSET := OFS (DATA); {set data buffer address}
USER_BUF_LEN := DATALEN;
USER_FCB_ADDR.SEGMENT := SEG (POS);
USER_FCB_ADDR.OFFSET := OFS (POS); {set FCB address}
USER_CUR_ADDR.SEGMENT := USER_FCB_ADDR.SEGMENT; {set cur seg}
USER_CUR_ADDR.OFFSET := USER_FCB_ADDR.OFFSET+38;{set cur ofs}
USER_FUNCTION := OP; {set Btrieve operation code}
USER_KEY_ADDR.SEGMENT := SEG (KBUF);
USER_KEY_ADDR.OFFSET := OFS (KBUF); {set key buffer address}
USER_KEY_LENGTH := 255; {assume its large enough}
USER_KEY_NUMBER := KEY; {set key number}
USER_STAT_ADDR.SEGMENT := SEG (STAT);
USER_STAT_ADDR.OFFSET := OFS (STAT); {set status address}
XFACE_ID := VAR_ID; {set lamguage id}
end;
REGS.DX := OFS (XDATA);
REGS.DS := SEG (XDATA);
if (NOT MULTI) then {MultiUser version not installed}
INTR (BTR_INT, REGS)
else
begin
DONE := FALSE;
repeat
REGS.BX := ProcId;
REGS.AX := 1;
if (REGS.BX <> 0) then
REGS.AX := 2;
REGS.AX := REGS.AX + (MULTI_FUNCTION * 256);
INTR (BTR2_INT, REGS);
if ((REGS.AX AND $00FF) = 0) then
DONE := TRUE
else begin
REGS.AX := $0200;
INTR ($7F, REGS);
DONE := FALSE;
end;
until (DONE);
if (ProcId = 0) then
ProcId := REGS.BX;
end;
DATALEN := XDATA.USER_BUF_LEN;
end;
BTRV := STAT;
end;
{$B-}
{$V+}
(* BRECMGR.INIT Constructor *)
(* ------------------------ *)
constructor TRecMgr.Init;
var
Counter : integer;
BNumber,
BRev : string[2];
BProduct : string[1];
begin
TObject.Init; {assures all data fields zeroed}
BStatus := Btrv(BVersion, VarPosBlk, Version, Counter, VarNotRequired, Zero);
str(Version.Number:2, BNumber);
BNumber := LTrim(BNumber);
str(Version.Rev:2, BRev);
BProduct := Version.Product;
VersionString := BNumber + '.' + BRev + BProduct;
end;
(* BRECMGR.BT function *)
(* ------------------- *)
{Will not handle reset of other workstations as written, as no true key
buffer is passed. Will handle begin/end/abort transaction, reset & stop.
Would also handle version op, but is handled by BRecMgr.Init anyway!}
function TRecMgr.BT(OpCode, Key: integer): integer;
begin
BT := Btrv(OpCode, VarPosBlk, VarNotRequired, VarNotRequired,
VarNotRequired, Key);
end;
(* BRECMGR Destructor *)
(* ------------------ *)
destructor TRecMgr.Done;
begin
TObject.Done;
end;
(* TALTCOLSEQ.INIT Constructor *)
(* ---------------------------- *)
constructor TAltColSeq.Init(SpecName: FNameStr);
var
AltFile: file of TAltColSpec; {The TAltColSpec object type is used }
begin {internally by the CreateFile function.}
TObject.Init;
assign(AltFile, SpecName);
{$I-} reset(AltFile); {$I+} {It's up to user program to assure that the}
if ioresult = 0 then {alternate collating sequence file exists }
begin {in the current directory when the }
read(AltFile, Spec); {CreateFile fcn is called, and is of the }
close(AltFile); {standard format expected by Btrieve. }
end
else
Fail;
end;
(* TALTCOLSEQ.DONE Destructor *)
(* --------------------------- *)
destructor TAltColSeq.Done;
begin
TObject.Done;
end;
(* BFILE.INIT Constructor *)
(* ---------------------- *)
constructor BFile.Init(UserFileName: FNameStr; OpenMode: integer);
const {665 = 16 for filespec + 384 for max key specs}
FileBufLen : integer = 665; {+ 265 for an alternate collating sequence. }
KeyBufLen : integer = 384; {Max of 24 keys * 16 bytes per key spec.}
var
AltColNameOffset,
Counter, Counter1,
Status : integer;
NumRecsWord1,
NumRecsWord2 : word;
procedure CountSegments;
begin
repeat
if (Specs.KeyArray[Counter1].KeyFlags and Segmented) = Segmented then
begin
if (Specs.KeyArray[Counter1].KeyFlags and AltCol) = AltCol then
HasAltCol := true;
inc(NumSegs);
inc(Counter1);
end
else
begin
if (Specs.KeyArray[Counter1].KeyFlags and AltCol) = AltCol then
HasAltCol := true;
inc(Counter);
inc(Counter1);
end;
until (Specs.KeyArray[Counter1].KeyFlags and Segmented) <> Segmented;
end;
begin
TObject.Init; {assures all data fields zeroed}
HasAltCol := false; {initialize to false 'until proven guilty!'}
ConvertName(UserFileName); {Sets fields DFileName and FileName}
Status := Open(OpenMode);
if Status = 0 then {if open op successful, do a stat op}
begin
Status := Btrv(BStat, PosBlk, Specs.SpecBuf, FileBufLen, KeyBufLen,
Zero);
{Btrieve filespecs and key specs are now in the BFile object!}
{Typed constant FileBufLen will have been changed to size of data
buffer returned by stat call. Save that value now.}
SpecLength := FileBufLen;
if Status = 0 then {if stat successfull, fill object data fields}
begin
NumRecsWord1 := Specs.NumRecs[1]; {get rid of sign bit!! by }
NumRecsWord2 := Specs.NumRecs[2]; {converting 2 ints to words}
NumRecs := NumRecsWord1 + NumRecsWord2 * 65536;
NumSegs := Specs.NumKeys;
Counter := 1; Counter1 := 0;
while Counter <= Specs.NumKeys do {Will be skipped if data}
CountSegments; {only file. }
if HasAltCol = true then
begin
AltColNameOffset := (16+16*NumSegs+1);
for Counter := 1 to 8 do
AltColName[Counter] := chr(Specs.Entire[AltColNameOffset + Counter]);
end;
DBufferLen := Specs.RecLen;
BStatus := 0; {all went well, return a code 0}
end
else
begin
BStatus := Status; {Open op succeeded but stat failed; put }
Status := Close; {error code for bad stat in global var and}
end; {close the damn file quick!}
end
else
BStatus := Status; {assign err code for bad open to global var}
end;
(* BFILE.BT function *)
(* ----------------- *)
function BFile.BT(OpCode, Key: integer): integer;
begin
Abstract;
end;
(* BFILE.OPEN function *)
(* ------------------- *)
function BFile.Open(OpenMode: integer):integer;
begin
Open := Btrv(BOpen, PosBlk, VarNotRequired, Specs.RecLen, FileName, OpenMode);
end;
(* BFILE.CLOSE Function *)
(* -------------------- *)
function BFile.Close:integer;
begin
Close := Btrv(BClose, PosBlk, VarNotRequired, VarNotRequired,
VarNotRequired, NotRequired);
end;
(* BFILE.DONE Destructor *)
(* --------------------- *)
destructor BFile.Done;
begin
TObject.Done;
end;
(* BFILE.CONVERTNAME Procedure *)
(* --------------------------- *)
{this one is private to BFile}
procedure BFile.ConvertName(UserFileName: FNameStr);
begin
DFileName := UserFileName;
move(DFileName[1], FileName[1], length(DFileName)); {conv string to array}
FileName[length(DFileName) + 1] := ' '; {provide required pad char}
end;
(* BFIXED.INIT Constructor *)
(* ----------------------- *)
constructor BFixed.Init(UserFileName: FNameStr; OpenMode: integer);
begin
BFile.Init(UserFileName, OpenMode);
end;
(* BFIXED.BT function *)
(* ----------------- *)
function BFixed.BT(OpCode, Key: integer): integer;
begin
BT := Btrv(OpCode, PosBlk, DBuffer, Specs.RecLen, KBuffer, Key);
end;
(* BFIXED.DONE Destructor *)
(* ---------------------- *)
destructor BFixed.Done;
begin
BFile.Done;
end;
(* TFILTERSPEC.INITF Constructor *)
(* ----------------------------- *)
{Be sure to remember that the offset parameter here is 0 relative to start of
record!!}
constructor TFilterSpec.InitF(FieldType: byte; FieldLen, Offset: integer;
CompCode, Expression: byte; CompOffset: integer);
begin
TObject.Init; {assures all data fields zeroed}
LogicTerm.FieldType := FieldType;
LogicTerm.FieldLen := FieldLen;
LogicTerm.Offset := Offset;
LogicTerm.CompCode := CompCode;
LogicTerm.Expression := Expression;
LogicTerm.FieldComp := true;
LogicTerm.CompOffset := Offset;
end;
(* TFILTERSPEC.INITV Constructor *)
(* ----------------------------- *)
{Be sure to remember that the offset parameter here is 0 relative to start of
record!!}
constructor TFilterSpec.InitV(FieldType: byte; FieldLen, Offset: integer;
CompCode, Expression: byte; Value: TCharArray);
begin
TObject.Init; {assures all data fields zeroed}
LogicTerm.FieldType := FieldType;
LogicTerm.FieldLen := FieldLen;
LogicTerm.Offset := Offset;
LogicTerm.CompCode := CompCode;
LogicTerm.Expression:= Expression;
LogicTerm.FieldComp := false;
LogicTerm.Value := Value;
end;
(* TFILTERSPEC.DONE Destructor *)
(* --------------------------- *)
destructor TFilterSpec.Done;
begin
TObject.Done;
end;
(* TEXTSPEC.INIT Constructor *)
(* ------------------------- *)
constructor TExtSpec.Init(Len, Ofs: integer);
begin
TObject.Init; {assures all data fields zeroed}
ExtRepeater.FieldLen := Len;
ExtRepeater.Offset := Ofs;
end;
(* TEXTSPEC.DONE Destructor *)
(* ----------------------- *)
destructor TExtSpec.Done;
begin
TObject.Done;
end;
(* BFILEEXT.INIT Constructor *)
(* ------------------------- *)
{always check for a failure!}
constructor BFileExt.Init(UserFileName: FNameStr; OpenMode: integer);
begin
BFile.Init(UserFileName, OpenMode);
Header.Constant[1] := 'E';
Header.Constant[2] := 'G';
ExtDBuffer := memallocseg(MaxExtDBufferLength);
FilterSpec := new(PCollection, Init(2,2));
ExtractorSpec := new(PCollection, Init(5,2));
if (ExtDBuffer = nil) or (FilterSpec = nil) or (ExtractorSpec = nil) then
Fail;
end;
(* BFILEEXT.DONE Destructor *)
(* ------------------------ *)
destructor BFileExt.Done;
begin
BFile.Done;
dispose(ExtDBuffer);
dispose(ExtractorSpec, Done);
dispose(FilterSpec, Done);
end;
(* BFILEEXT.SETEXTDBUFFERLEN function *)
(* ---------------------------------- *)
{Compute sizes of data buffers sent and returned, to determine proper size to
specify in call.}
{Assumes user program has inserted proper items into the collections for
filter terms and extractor specs.}
procedure BFileExt.SetExtDBufferLen;
var
LengthSent, LengthReturned,
RecordLengthReturned, RecordImageReturned : integer;
procedure MakeFilterSpecs;
procedure CalcFilterLengths(FSpec: PFilterSpec); far;
begin
with FSpec^ do
begin
inc(LengthSent, 7);
if (LogicTerm.CompCode and UseField) = UseField then
inc(LengthSent, 2)
else
LengthSent := LengthSent + LogicTerm.FieldLen;
end;
end;
begin
FilterSpec^.ForEach(@CalcFilterLengths);
end;
procedure MakeExtSpecs;
procedure CalcExtLengths(ExtSpec: PExtSpec); far;
begin
with ExtSpec^ do
begin
inc(LengthSent, 4);
RecordLengthReturned := RecordLengthReturned + ExtRepeater.FieldLen;
end;
end;
begin
ExtractorSpec^.ForEach(@CalcExtLengths);
end;
begin
LengthSent := 8; {4 for header length, 4 for fixed filter length}
{Work on filter logic term portion of spec.}
if FilterSpec^.Count > 0 then {if any filter terms in the collection}
MakeFilterSpecs;
{Work on extractor portion of spec.}
inc(LengthSent, 4); {size of fixed part of extractor}
RecordLengthReturned := 0;
MakeExtSpecs; {there must always be at least 1 extractor spec}
{2 for count of recs, 4 for currency pos}
RecordImageReturned := RecordLengthReturned + 6;
{2 for count of recs}
LengthReturned := 2 + (RecordImageReturned * Extractor.NumRecords);
Header.DBufferLen := LengthSent;
if LengthSent >= LengthReturned then
DBufferLen := LengthSent
else
DBufferLen := LengthReturned;
end;
(* BFILEEXT.MAKEEXTDBUFFER Function *)
(* -------------------------------- *)
{Private to BFileExt, called in BFileExt.BT, which is called by each
descendant's override of BFileExt.BT. Assumes program has already set up
the collections required.}
procedure BFileExt.MakeExtDBuffer;
var
Offset : integer;
procedure MoveFilterSpecs;
procedure MoveSingleFilterSpec(FSpec: PFilterSpec); far;
begin
with FSpec^ do
begin
{move fixed part of logic term}
move(LogicTerm, ExtDBuffer^.Entire[Offset], sizeof(LogicTerm.Fixed));
inc(Offset, sizeof(LogicTerm.Fixed));
{now need to move variable part of logic term}
if (LogicTerm.CompCode and UseField) = UseField then
begin
move(LogicTerm.CompOffset, ExtDBuffer^.Entire[Offset],
sizeof(LogicTerm.CompOffset));
Offset := Offset + sizeof(LogicTerm.CompOffset);
end
else
begin
move(LogicTerm.Value, ExtDBuffer^.Entire[Offset],
LogicTerm.FieldLen);
Offset := Offset + LogicTerm.FieldLen;
end;
end;
end;
begin
FilterSpec^.ForEach(@MoveSingleFilterSpec);
end;
procedure MoveExtractorSpecs;
procedure MoveSingleExtractorSpec(ExtSpec: PExtSpec); far;
begin
with ExtSpec^ do
begin
move(ExtSpec^.ExtRepeater, ExtDBuffer^.Entire[Offset],
sizeof(ExtSpec^.ExtRepeater));
Offset := Offset + sizeof(ExtSpec^);
end;
end;
begin
ExtractorSpec^.ForEach(@MoveSingleExtractorSpec);
end;
begin
{Move header definition into buffer.}
move(Header, ExtDBuffer^.Header, sizeof(Header));
{Move fixed part of filter definition into buffer.}
move(Filter, ExtDBuffer^.Filter, sizeof(Filter));
Offset := 1 + sizeof(Header) + sizeof(Filter);
{Read filter logic terms into buffer.}
if FilterSpec^.Count > 0 then
MoveFilterSpecs;
{Move fixed part of extractor definition into buffer.}
move(Extractor, ExtDBuffer^.Entire[Offset], sizeof(Extractor.Entire));
Offset := Offset + sizeof(Extractor.Entire);
{Move extractor terms into buffer.}
MoveExtractorSpecs;
end;
(* BFILEEXT.BTEXT function *)
(* ----------------------- *)
{In overrides of this function in BFileExt descendants, MUST call
BFileExt.BTExt, as it sets the buffer length in the header, and puts
together the 'send' buffer. User program MUST have inserted filter logic
terms and extractor specs into their respective collections before making
a Btrieve call.}
function BFileExt.BTExt(OpCode, Key: integer): integer;
begin
SetExtDBufferLen;
MakeExtDBuffer;
end;
(* CREATEFILE function *)
(* -------------------- *)
{Assumes a PFILESPEC variable has been instantiated and assigned its values,
and that if you use an alternate collating sequence, it exists in the
current directory.}
{No specific support for null keys, blank compression, data-only files.}
function CreateFile(UserFileName: FNameStr; UserFileSpec:PFileSpec;
AltColFile: FNameStr): integer;
var
CFSpecLength,
Counter,
Counter1,
NumSegs : integer;
BtrieveFileName : BFileName;
HasAltCol : boolean;
AltColObj : PAltColSeq;
procedure CountSegments;
begin
with UserFileSpec^ do
repeat
if (KeyArray[Counter1].KeyFlags and Segmented) = Segmented then
begin
if (KeyArray[Counter1].KeyFlags and AltCol) = AltCol then
HasAltCol := true;
inc(NumSegs);
inc(Counter1);
end
else
begin
if (KeyArray[Counter1].KeyFlags and AltCol) = AltCol then
HasAltCol := true;
inc(Counter);
inc(Counter1);
end;
until (KeyArray[Counter1].KeyFlags and Segmented) <> Segmented;
end;
begin
move(UserFileName[1], BtrieveFileName[1], length(UserFileName));
BtrieveFileName[length(UserFileName) + 1] := ' ';
Counter := 1; Counter1 := Counter;
NumSegs := UserFileSpec^.NumKeys;
while Counter <= UserFileSpec^.NumKeys do
CountSegments;
CFSpecLength := 16 + (NumSegs * 16);
UserFileSpec^.Reserved[1] := chr(0);
UserFileSpec^.Reserved[2] := chr(0);
if (AltColFile <> '') and (HasAltCol = true) then {Note the double check!}
begin
AltColObj := new(PAltColSeq, Init(AltColFile));
move(AltColObj^.Spec, UserFileSpec^.Entire[CFSpecLength+1],
sizeof(AltColObj^.Spec));
CFSpecLength := CFSpecLength + sizeof(AltColObj^.Spec);
dispose(AltColObj, Done);
end;
CreateFile := Btrv(BCreate, VarPosBlk, UserFileSpec^.SpecBuf, CFSpecLength,
BtrieveFileName, Zero);
end;
(* CLONEFILE function *)
(* ------------------ *)
{Programmer is responsible for assuring that 'CurrentFile' exists and can be
opened. Function will overwrite any existing file with 'NewFile' name.
The integer returned here can be meaningless if the current file does not
exist or is not opened properly. This function is as streamlined as
possible, but puts RESPONSIBILITY on the programmer.
It is entirely possible that this clone function will NOT return a byte for
byte matching file, if cloning an 'empty' Btrieve file. This would be due
to the inability to determine the number of pages pre-allocated when a file
was created, if preallocation had been used. The Btrieve Stat call uses
the 'Preallocate # of pages' bytes to return the number of unused pages!!
Thus, the CloneFile function clears the Preallocation bit in the FileFlags,
among other things, before creating the new file.}
function CloneFile(CurrentFile, NewFile:FNameStr): integer;
var
Counter, Counter1 : integer;
CurrentBFile : PBFile;
NewBFile : BFileName;
begin
CurrentBFile := new(PBFile, Init(CurrentFile, ReadOnly));
move(NewFile[1], NewBFile[1], length(NewFile));
NewBFile[length(NewFile) + 1] := ' ';
{Undo the 'damage' due to a virgin filespec by the stat call on init of
the CurrentBFile object...tho technically the 'NotUsed' bytes we clear
in the next 'if' probably do NOT really need to be cleared.}
if CurrentBFile^.NumSegs > 0 then {don't do if data only file}
{Zero the bytes that after the init call hold # unique records!}
for Counter := 1 to CurrentBFile^.NumSegs do
fillchar(CurrentBFile^.Specs.KeyArray[Counter].NotUsed, 4, 0);
{Clear the PreAllocate file flag bit if it had been set in CurrentBFile.}
CurrentBFile^.Specs.FileFlags := CurrentBFile^.Specs.FileFlags and $FD;
CurrentBFile^.Specs.UnusedPgs := 0; {If preallocate file flag was set, the}
{cloned file will have no pages pre- }
{allocated...NO way to get the }
{original # of pre-allocated pages! }
CloneFile := Btrv(BCreate, VarPosBlk, CurrentBFile^.Specs,
CurrentBFile^.SpecLength, NewBFile, Zero);
BStatus := CurrentBFile^.Close;
dispose(CurrentBFile, Done);
end;
{LTrim and RTrim were taken from one of the Turbo Vision .PAS source files!}
function LTrim(S: String): String;
var
I: integer;
begin
I := 1;
while (I < length(S)) and (S[I] = ' ') do inc(I);
LTrim := copy(S, I, 255);
end;
function RTrim(S: String): String;
var
I: integer;
begin
while S[Length(S)] = ' ' do dec(S[0]);
RTrim := S;
end;
(* IS BTRIEVE LOADED procedure *)
(* --------------------------- *)
{this is private to the unit, and is executed only during unit initialization}
procedure IsBtrieveLoaded;
begin
BStatus := Btrv(BReset, VarPosBlk, VarNotRequired, VarNotRequired,
VarNotRequired, Zero);
if BStatus = 20 then
begin
writeln('Please load Btrieve before running this program.');
halt;
end;
end;
(* INITIALIZATION Section *)
(* ----------------------------------------------------------------------- *)
BEGIN
IsBtrieveLoaded;
END.